home *** CD-ROM | disk | FTP | other *** search
/ Libris Britannia 4 / science library(b).zip / science library(b) / COMMUNIC / BULLETIN / 1484B.ZIP / READ.LIB < prev    next >
Text File  |  1988-04-06  |  4KB  |  163 lines
  1.  
  2.  
  3. { Sample Message Read Function }
  4. { (c) Copyright 1988 Searchlight Software }
  5.  
  6.  
  7. { The following procedures will display the text of a message in the
  8.   MESSAGE.BBS file.  It is assumed that the message file is opened as 
  9.   msgfile: file of textype.  To use this routine, call UnpackMsg(rec) 
  10.   where 'rec' is the record number in the message file containing the 
  11.   first block of message text (NOT the header record).  You should 
  12.   include both FILEDEF.LIB and this file in your program.  
  13.  
  14.   Searchlight BBS compresses messages with the COMPRESS function before
  15.   storing them; the UNCOMPRESS routine is used to read them back.  If you
  16.   store data in the message file, it is not necessary to compress it
  17.   first, but we include the COMPRESS function below if you want to.   }
  18.  
  19.  
  20.  
  21. { -- String Compression Functions -------------------------------------- }
  22.  
  23.  
  24. const eol = #13;                 { CR character }
  25. type longstr = string[255];      { maximum length string }
  26.  
  27.  
  28. Procedure Compress (var str: longstr);
  29.  
  30.   { compress a text string. 2 methods:
  31.     1) collapse multicharacter sequences to 3-byte codes;
  32.     2) remove spaces by setting 8th bit of suceeding byte.
  33.        only performed if string contains no 8-bit bytes.    }
  34.  
  35. var i,p: byte;
  36.     eightbit,comp: boolean;
  37.  
  38. Begin
  39.   eightbit:=false;   { 8-bit character flag }
  40.  
  41.   p:=1;
  42.   while (p<=length(str)-4) do begin        { run-length encoding }
  43.     eightbit:=eightbit or (str[p]>#127);
  44.     if (str[p]=str[p+1]) then
  45.       if (str[p]=str[p+2]) then
  46.         if (str[p]=str[p+3]) then
  47.         begin
  48.           i:=p+2;
  49.           repeat i:=i+1
  50.           until (i=length(str)) or (str[i+1]<>str[p]);
  51.           delete(str,p+3,i-p-2);
  52.           str[p]:=#01;
  53.           str[p+1]:=chr(i-p+1);
  54.           if str[p+1]=eol then str[p+1]:=#0;
  55.           p:=p+2;
  56.         end;
  57.     p:=p+1;
  58.   end;
  59.   for p:=p to length(str) do
  60.     eightbit:=eightbit or (str[p]>#127);
  61.  
  62.   if not eightbit then begin               { space replacement }
  63.     comp:=false;
  64.     i:=pos(' ',str);
  65.     while (i>0) and (i<length(str)) and (str[i+1]<#128) do begin
  66.       comp:=true;
  67.       delete(str,i,1);
  68.       str[i]:=chr(byte(str[i]) or 128);
  69.       i:=pos(' ',str);
  70.     end;
  71.     if comp then insert(#02,str,1);
  72.   end;
  73.  
  74. end;
  75.  
  76.  
  77.  
  78. Procedure Uncompress (var str: longstr);
  79.   { un-compress string packed by compress routine }
  80. var i: byte;
  81.     c: char;
  82.     object: longstr;
  83.  
  84. Begin
  85.  
  86.   if str[1]=#02 then begin      { reverse space-delete compression }
  87.     delete(str,1,1);
  88.     i:=1;
  89.     while (i<=length(str)) do begin
  90.       if str[i]<#128 then i:=i+1
  91.       else begin
  92.         str[i]:=chr(byte(str[i]) and 127);
  93.         insert(' ',str,i);
  94.         i:=i+2;
  95.       end;
  96.     end;
  97.   end;
  98.  
  99.   i:=pos(#01,str);              { reverse run-length compression }
  100.   while (i>0) do begin
  101.     object[0]:=str[i+1];
  102.     if object[0]=#0 then object[0]:=eol;
  103.     c:=str[i+2];
  104.     fillchar(object[1],length(object),c);
  105.     delete(str,i,3);
  106.     insert(object,str,i);
  107.     i:=pos(#01,str);
  108.   end;
  109.  
  110. end;
  111.  
  112.  
  113.  
  114. Procedure UnpackMsg (rec: integer);
  115.   { unpack message and display it on the screen }
  116.  
  117. var temprec: textype;
  118.     newline: boolean;
  119.     eolpos,lasteol: integer;
  120.     tempstr: longstr;
  121.  
  122.  
  123. Begin
  124.   tempstr[0]:=#0;      { clear temp string }
  125.  
  126.   while (rec<>0) do begin
  127.     seek(msgfile,rec);
  128.     read(msgfile,temprec);      { read next record from file }
  129.  
  130.     if not temprec.header then     { skip header }
  131.     begin
  132.  
  133.       lasteol:=0;
  134.       repeat
  135.  
  136.         eolpos:=pos(eol,temprec.data);       { check for CR }
  137.         if eolpos=0 then begin
  138.           eolpos:=length(temprec.data)+1;
  139.           newline:=false;
  140.         end
  141.         else newline:=true;
  142.  
  143.         tempstr:=tempstr+copy(temprec.data,lasteol+1,eolpos-lasteol-1);
  144.  
  145.         if newline then temprec.data[eolpos]:=#0;
  146.         lasteol:=eolpos;
  147.  
  148.         if newline then begin
  149.           uncompress(tempstr);      { uncompress string }
  150.           writeln(tempstr);         { print it }
  151.           tempstr[0]:=#0;           { clear for next line }
  152.         end;
  153.  
  154.       until (eolpos>=length(temprec.data));
  155.  
  156.     end;
  157.     rec:=temprec.next;
  158.  
  159.   end;
  160.  
  161. end;
  162.  
  163.